Usenet 1993 July

home *** CD-ROM | disk | FTP | other *** search

/ Usenet 1993 July / InfoMagic USENET CD-ROM July 1993.ISO / sources / misc / volume12 / ffccc / part04 < prev next >

Wrap

Text File | 1990-05-14 | 47.2 KB | 1,206 lines

Newsgroups: comp.sources.misc organization: CERN, Geneva, Switzerland keywords: fortran subject: v12i090: Floppy - Fortran Coding Convention Checker Part 04/11 from: julian@cernvax.cern.ch (julian bunn) Sender: allbery@uunet.UU.NET (Brandon S. Allbery - comp.sources.misc) Posting-number: Volume 12, Issue 90 Submitted-by: julian@cernvax.cern.ch (julian bunn) Archive-name: ffccc/part04 #!/bin/sh echo 'Start of Floppy, part 04 of 11:' echo 'x - ALLPRO.f' sed 's/^X//' > ALLPRO.f << '/' X SUBROUTINE ALLPRO X*----------------------------------------------------------------------- X* X*--- Overall control of FLOP run. X* X*----------------------------------------------------------------------- X include 'PARAM.h' X include 'ALCAZA.h' X include 'JOBSUM.h' X include 'FLAGS.h' X include 'STATE.h' X*--- print header X CALL HEADER X*--- initialize X CALL FLINIT X CALL STADEF X*--- read command lines X CALL INDECO X CALL INDECT X*--- user total initialization X IF(ACTION(22)) CALL UTINIT X*--- start processing X 10 CONTINUE X*--- process if enough time left (only if CERN flag on) X IF(.NOT.STATUS(4)) THEN X*--- read one complete routine X CALL READEC X*--- process if still something read X IF (.NOT.STATUS(2)) THEN X*--- count lines X DO 20 I=NFLINE(1),NLLINE(NSTAMM) X IF (NLTYPE(I).EQ.0) NSTATC(7)=NSTATC(7)+1 X IF (NLTYPE(I).EQ.1) NSTATC(3)=NSTATC(3)+1 X 20 CONTINUE X NSTATC(1)=NSTATC(1)+NLLINE(NSTAMM)-NFLINE(1)+1 X*--- set pointer and count for routine name list X NRNAME=0 X IRNAME=IGNAME+NGNAME X*--- process one complete routine X CALL PROCES X IF (NRNAME.GT.0) THEN X IF (ACTION(25)) THEN X*--- print list of routine names X WRITE (MPUNIT,10000) SCROUT,NRNAME X IF (ACTION(20)) THEN X*--- print name list with types X CALL PRNAMF(IRNAME+1,IRNAME+NRNAME) X ELSE X WRITE (MPUNIT,10010) (SNAMES(IRNAME+J),J=1,NRNAME) X ENDIF X ENDIF X IF (ACTION(2)) THEN X*--- merge with global namelist X CALL LMERGE(SNAMES,NAMTYP,.TRUE.,IGNAME,NGNAME,NRNAME) X CALL SUPMUL(SNAMES,NAMTYP,.TRUE.,IGNAME,NGNAME+NRNAME, X + NGNAME) X ENDIF X ENDIF X IF(ACTION(27).AND..NOT.STATUS(12)) THEN X*--- print common block information X CALL PRTCOM X ENDIF X*--- write output file X CALL PUTOUT X GOTO 10 X ENDIF X ENDIF X*--- user total termination X IF(ACTION(22)) CALL UTTERM X CALL SUMMRY X10000 FORMAT(//' Routine = ',A8,', list of',I6,' names'/) X10010 FORMAT(1X,10A10) X END / echo 'x - INDECO.f' sed 's/^X//' > INDECO.f << '/' X SUBROUTINE INDECO X*----------------------------------------------------------------------- X* X* Complete processing of user commands on input. X* The input is received from routine INUSER. X* The output is stored in commons /FLAGS/, /KEYINP/, and /SKEYNP/ X* X*----------------------------------------------------------------------- X include 'PARAM.h' X include 'ALCAZA.h' X include 'STATE.h' X include 'KEYCOM.h' X include 'FLAGS.h' X include 'FLWORK.h' X include 'CLASS.h' X include 'CONDEC.h' X* X DIMENSION NSUBKY(MTOTKY),KSUBKY(MTOTKY),KDEFKY(MTOTKY), KACTKY X +(MTOTKY),KLISKY(MTOTKY),KKEYLS(MTOTKY),KKEYLG(MTOTKY), KSUBRF X +(MSUBKY),KSUBIX(MSUBKY),KSUBAC(MSUBKY),KSUBLG(MSUBKY), KSUBLS X +(MSUBKY),KDEFAU(7,2),IBIT(3) X* NSUBKY(I) = # of sub-keys of key I X* KSUBKY(I) = start-1 of sub-key list in KSUBRF X* KDEFKY(I) = default flag if no sub-key given X* KACTKY(I) = action flag to be set by key I X* KLISKY(I) = cumulative 'type of input' indicator: X* 1 integer list given X* 2 name list given X* 4 string list given X* KKEYLS(I) = for key I, ref. to KDEFAU for numerical default values X* KKEYLG(I) = for key I, no. of numerical default values in KDEFAU X* KSUBRF = ref. list of sub-keys X* KSUBIX(J) = for sub-key number J, 'type of action' indicator: X* -2 insert list of non-executable statements X* -1 insert list of executable statements X* > 0: p, where p is the position of the first integer X* behind the sub-key of the integer list (FORMAT=... etc.) X* KSUBLG(J) = for sub-key number J, no. of words for default values X* KSUBAC(J) = for sub-key number J, action flag to be set, or zero X* KSUBLS(J) = for sub-key J, ref. to default integer list X* KDEFAU(I,J) = for above ref., defaults X* IBIT = temporary storage for bits from KLISKY X CHARACTER*3 STRKEY(MTOTKY),SUBKEY(MSUBKY) X* STRKEY = list of keys X* SUBKEY = list of sub-keys X CHARACTER STEMP*1,STEMP3*3,SLNAM*(MXNMCH) X DATA STRKEY/'OR;','END','PRI','LIS','OUT','FIR','STA','OPT', 'REP' X +,'ROU','NAM','STR','CLA'/ X DATA SUBKEY/'CHA','END','FOR','FUL','GLO','ILL','IND','NUM', 'QUO' X +,'RET','SEP','EXE','NEX','PAR','CHA','PAR','FUL','SEP', 'TYP', X +'USE','COM','COM','GOT','TRE'/ X DATA NSUBKY/0,0,4,3,4,0,6,5,0,0,0,0,2/ X DATA KSUBKY/0,0,0,4,7,11,11,17,22,22,22,22,22/ X DATA KDEFKY/0,0,5,1,8,0,0,0,0,0,0,0,0/ X DATA KACTKY/0,0,0,0,0,10,13,0,0,16,18,19,17/ X DATA KLISKY/0,0,0,0,0,0,0,0,6,2,2,4,1/ X DATA KKEYLS/6*0,1,6*0/ X DATA KKEYLG/6*0,7,6*0/ X DATA KSUBRF/1,4,6,14,5,11,19,15,16,17,21,2,3,8,10,18,23,24,7,9, X +20,22,12,13/ X DATA KSUBIX/0,7,3,0,0,0,1,1,2,5,0,-1,-2,8*0,3,2*0/ X DATA KSUBLG/0,7,7,0,0,0,3,7,3,7,11*0,3,2*0/ X DATA KSUBAC/4,0,0,6,2,3,21,0,11,0,1,0,0,5,7,8,9,14,20,22,23,27, X +28,29/ X DATA KSUBLS/0,0,0,0,0,0,2,0,2,12*0,2,2*0/ X*--- in KDEFAU, under 1: X* defaults for statement numbers(2),formats(2),returns(2),end(1) X* under 2: defaults for INDFAC (1), and IBLPAD (1) X DATA KDEFAU/10,10,0,10,0,1,0, 3,1,0,4*0/ X X* X include 'CONDAT.h' X*--- read all input commands, pre-process, store in SIMA X CALL INUSER X*--- check for illegal keys X IPR=0 X DO 20 IS=1,NSTAMM X STEMP3=SIMA(NFLINE(IS))(1:3) X DO 10 IC=1,MTOTKY X IF (STEMP3.EQ.STRKEY(IC)) GOTO 20 X 10 CONTINUE X WRITE (MPUNIT,10020) STEMP3 X IF (IPR.EQ.0) THEN X WRITE (MPUNIT,10030) STRKEY X IPR=1 X ENDIF X 20 CONTINUE X*--- start decoding X NKEY=0 X*--- loop over global (IORSET=0) and local keys X DO 160 IORSET=0,NORSET X IF (IORSET.EQ.0) THEN X ILOW=3 X IUP=MGLOKY X I1=1 X I2=NSTAMM X ELSE X ILOW=MGLOKY+1 X IUP=MTOTKY X ENDIF X DO 150 IKY=ILOW,IUP X NSINT=0 X NFINT=0 X IF (IORSET.NE.0) THEN X I1=NSSTRT(IORSET) X I2=NSEND(IORSET) X ENDIF X*--- collect all occurences (either globally, or in this OR-set) X* of this key X CALL INEXTR(STRKEY(IKY),I1,I2,NL) X*--- complete key now in SSTA, length NL (characters), cleaned X* from key-words. X IF (NL.LT.0) GOTO 150 X*--- set bit string for integer list etc. X N=KLISKY(IKY) X DO 30 J=3,1,-1 X IBIT(J)=N/2**(J-1) X N=N-IBIT(J)*2**(J-1) X 30 CONTINUE X*--- count X IF (IORSET.EQ.0) THEN X NGLSET=NGLSET+1 X ELSE X IF (NORCOM(IORSET).EQ.0) KORCOM(IORSET)=NKEY X NORCOM(IORSET)=NORCOM(IORSET)+1 X ENDIF X NKEY=NKEY+1 X KEYREF(NKEY,1)=IKY X*--- set action flags X IF (KACTKY(IKY).NE.0) THEN X ACTION(KACTKY(IKY))=.TRUE. X ENDIF X*--- defaults for keys X IF (KKEYLS(IKY).GT.0.AND.KEYREF(NKEY,2).EQ.0) THEN X NKS=KKEYLG(IKY) X KEYREF(NKEY,2)=NKS X KEYREF(NKEY,3)=NKYINT X KK=KKEYLS(IKY) X DO 40 JJ=1,NKS X NKYINT=NKYINT+1 X KEYINT(NKYINT)=KDEFAU(JJ,KK) X 40 CONTINUE X ENDIF X*--- sub-keys X NSFD=0 X DO 80 JS=1,NSUBKY(IKY) X JSC=KSUBKY(IKY)+JS X JSN=KSUBRF(JSC) X IF(NL.EQ.0) THEN X IND=0 X ELSE X IND=INDEX(SSTA(:NL),SUBKEY(JSN)) X ENDIF X IF (IND.GT.0) THEN X*--- sub-key found X NSFD=1 X CALL SKIPTP(2,SSTA,IND,NL,.FALSE.,JPT,ILEV) X IF (KSUBIX(JSN).GT.0) THEN X*--- integers following X IF (KEYREF(NKEY,2).EQ.0) THEN X*--- get length and reserve space X NKS=KSUBLG(JSN) X KEYREF(NKEY,2)=NKS X KEYREF(NKEY,3)=NKYINT X*--- set default values X KK=KSUBLS(JSN) X DO 50 JJ=1,NKS X NKYINT=NKYINT+1 X KEYINT(NKYINT)=KDEFAU(JJ,KK) X 50 CONTINUE X ENDIF X*--- integer position X IPOS=KSUBIX(JSN) X 60 CONTINUE X CALL GETNBL(SSTA(JPT+1:NL),STEMP,N) X IF(N.GT.0.AND.(STEMP.EQ.'=' X + .OR.NUMCH(STEMP))) THEN X*--- next comma position X JCOM=JPT+INDEX(SSTA(JPT+1:NL),',') X IF(JCOM.EQ.JPT) JCOM=NL X*--- get integer X CALL GETINT(SSTA,JPT,JCOM,KFCH,KLCH,NN) X IF (KFCH.GT.0) THEN X*--- integer found X IF(NN.GT.0) KEYINT(KEYREF(NKEY,3)+IPOS)=NN X IPOS=IPOS+1 X JPT=JCOM X IF (IPOS.LE.NKS) GOTO 60 X ENDIF X ENDIF X ELSEIF(KSUBIX(JSN).LT.0) THEN X*--- EXE or NEX, add corresponding classes X NTYP=KSUBIX(JSN)+2 X*--- collect in IWS first X DO 70 JCL=1,NCLASS X IF (ISTMDS(11,JCL).EQ.NTYP) THEN X NSINT=NSINT+1 X IWS(NSINT)=ISTMDS(6,JCL) X ENDIF X 70 CONTINUE X ENDIF X IF (KSUBAC(JSN).GT.0) THEN X*--- action flag X ACTION(KSUBAC(JSN))=.TRUE. X ENDIF X ENDIF X*--- end of sub-key loop X 80 CONTINUE X IF (NSFD.EQ.0) THEN X*--- no sub-key found - set default flag if any X IF (KDEFKY(IKY).GT.0) ACTION(KDEFKY(IKY))=.TRUE. X ENDIF X*--- get integers if any X IF (IBIT(1).NE.0) THEN X JPT=0 X KADD=0 X 90 CONTINUE X CALL GETINT(SSTA,JPT+1,NL,KFCH,KLCH,NN) X IF (KFCH.GT.0) THEN X*--- integer found X JPT=KLCH X IF (KADD.EQ.0) THEN X NSINT=NSINT+1 X IWS(NSINT)=NN X ELSE X NFINT=NFINT+1 X IWS(KADD+NFINT)=NN X ENDIF X IF (JPT.LT.NL) THEN X*--- store those after IF ref. separately X IF (SSTA(JPT+1:JPT+1).EQ.'('.AND.KADD.EQ.0.AND. X + ISTMDS(6,IIF).EQ.NN) THEN X KADD=MXKINT X ELSEIF (SSTA(JPT+1:JPT+1).EQ.')') THEN X KADD=0 X ENDIF X GOTO 90 X ENDIF X ENDIF X*--- store integers (classes),in the following way: X* # of simple, plus those following, # of classes behind IF, X* plus those following X IF (NSINT.GT.0) THEN X KEYREF(NKEY,3)=NKYINT X*--- sort and suppress multiples X CALL SORTSP(NSINT,IWS,N) X KEYINT(NKYINT+1)=N X DO 100 J=1,N X KEYINT(NKYINT+J+1)=IWS(J) X 100 CONTINUE X CALL SORTSP(NFINT,IWS(MXKINT+1),NN) X KEYINT(NKYINT+N+2)=NN X DO 110 J=1,NN X KEYINT(NKYINT+N+J+2)=IWS(MXKINT+J) X 110 CONTINUE X KEYREF(NKEY,2)=N+NN+2 X NKYINT=NKYINT+KEYREF(NKEY,2) X ENDIF X ENDIF X*--- get names if any X IF (IBIT(2).NE.0) THEN X IPT=0 X 120 CONTINUE X*--- find name outside string X CALL GETNAM(SSTA,IPT+1,NL,KFCH,KLCH) X IF (KFCH.GT.0) THEN X*--- name found X IF (KEYREF(NKEY,4).EQ.0) KEYREF(NKEY,5)=NKYNAM X IF (NKYNAM.EQ.MXKNAM) THEN X WRITE (MPUNIT,10000) NKYNAM X GOTO 150 X ENDIF X SLNAM=' ' X SLNAM(:KLCH+1-KFCH)=SSTA(KFCH:KLCH) X IPT=KLCH X*--- enter name in table (alphabetic for each key) X K=KEYREF(NKEY,5) X CALL NAMTAB(SLNAM,SKEYLS(K+1),NKYNAM-K,IPOS) X IF (IPOS.GT.0) THEN X*--- name has been entered in table (otherwise already in) X IPOS=IPOS+K X DO 130 JJ=1,2 X DO 130 J=NKYNAM,IPOS,-1 X KNAMRF(J+1,JJ)=KNAMRF(J,JJ) X 130 CONTINUE X NKYNAM=NKYNAM+1 X KEYREF(NKEY,4)=KEYREF(NKEY,4)+1 X KNAMRF(IPOS,1)=0 X KNAMRF(IPOS,2)=0 X ENDIF X*--- check for string following if any X IF (IBIT(3).NE.0) THEN X IF (SSTA(IPT+1:IPT+1).EQ.'{') THEN X*--- delete string indicator (for string scan later on) X SSTA(IPT+1:IPT+1)=' ' X IND=INDEX(SSTA(IPT+1:NL),'}') X IF (IND.GT.2.AND.IPOS.GT.0) THEN X CALL INDECS(IPT+1,IPT+IND,*150) X KNAMRF(IPOS,1)=NKYSTR X ENDIF X IPT=IPT+MAX(IND,1) X ENDIF X*--- look for replacement string X IF (IPT+2.LT.NL.AND.SSTA(IPT+1:IPT+2).EQ.'={') X + THEN X IPT=IPT+1 X SSTA(IPT+1:IPT+1)=' ' X IND=INDEX(SSTA(IPT+1:NL),'}') X IF (IND.GT.2.AND.IPOS.GT.0) THEN X CALL INDECS(IPT+1,IPT+IND,*150) X KNAMRF(IPOS,2)=NKYSTR X ACTION(15)=.TRUE. X ENDIF X IPT=IPT+MAX(IND,1) X ENDIF X ENDIF X GOTO 120 X ENDIF X ENDIF X*--- check for strings to be replaced X IF (IBIT(3).NE.0) THEN X IPT=0 X 140 CONTINUE X IND=INDEX(SSTA(IPT+1:NL),'{') X IF (IND.GT.0) THEN X IPT=IPT+IND-1 X IND=INDEX(SSTA(IPT+1:NL),'}') X IF (IND.GT.2) THEN X IF (NKYCHR.EQ.MXKNAM) THEN X WRITE (MPUNIT,10010) NKYCHR X GOTO 150 X ENDIF X CALL INDECS(IPT+1,IPT+IND,*150) X IF (KEYREF(NKEY,6).EQ.0) KEYREF(NKEY,7)=NKYCHR X KEYREF(NKEY,6)=KEYREF(NKEY,6)+1 X NKYCHR=NKYCHR+1 X KSTREF(NKYCHR,1)=NKYSTR X ENDIF X IPT=IPT+MAX(IND,1) X*--- look for replacement string X IF (IPT+2.LT.NL.AND.SSTA(IPT+1:IPT+2).EQ.'={') THEN X IPT=IPT+1 X IND=INDEX(SSTA(IPT+1:NL),'}') X IF (IND.GT.2) THEN X CALL INDECS(IPT+1,IPT+IND,*150) X KSTREF(NKYCHR,2)=NKYSTR X ACTION(12)=.TRUE. X ENDIF X IPT=IPT+MAX(IND,1) X ENDIF X GOTO 140 X ENDIF X ENDIF X 150 CONTINUE X 160 CONTINUE X*--- look for indentation multiple request X INDFAC=0 X IBLPAD=1 X DO 170 I=1,NGLSET X IF (KEYREF(I,1).EQ.8) GOTO 180 X 170 CONTINUE X GOTO 190 X 180 CONTINUE X IF(KEYREF(I,2).GT.0) THEN X IF(ACTION(21)) INDFAC=MIN(5,KEYINT(KEYREF(I,3)+1)) X IF(ACTION(11)) IBLPAD=MIN(10,KEYINT(KEYREF(I,3)+2)) X IF(ACTION(27)) ICBPRT=KEYINT(KEYREF(I,3)+3) X ENDIF X 190 CONTINUE X ACTION(25)=ACTION(1) X ACTION(26)=ACTION(2) X*--- allow flags and options to be set directly X CALL SETREQ X ACTION(24)=ACTION(24).OR.ACTION(27).OR.ACTION(29) X ACTION(27)=ACTION(27).AND..NOT.ACTION(29) X ACTION(3)=ACTION(3).OR.ACTION(6) X*--- namelist / routine if common block option given, dito type X ACTION(1)=ACTION(1).OR.ACTION(24) X ACTION(20)=ACTION(20).OR.ACTION(24) X*--- print flags X ACTION(5)=ACTION(5).OR.ACTION(6) X ACTION(4)=ACTION(4).OR.ACTION(5) X10000 FORMAT(/1X,8('*=*='),' WARNING - max. no. of names =', I5, X +' reached in commands, rest ignored') X10010 FORMAT(/1X,8('*=*='),' WARNING - max. no. of strings =', I5, X +' reached in commands, rest ignored') X10020 FORMAT(/' *=*=*=*= WARNING - illegal key "',A,'" ignored',/) X10030 FORMAT(/' valid keys are:'/(1X,10A10)) X END / echo 'x - STADEF.f' sed 's/^X//' > STADEF.f << '/' X SUBROUTINE STADEF X*----------------------------------------------------------------------- X* X*--- initialises the statement classification by reading X*--- the statement descriptions from internal buffers (data X*--- statement) and filling the necessary arrays. X* X*--- output X* all variables in common/CLASS/ X* SSTM in COMMON/ALCAZA/ X* SNAM in COMMON/ALCAZA/ X* X*----------------------------------------------------------------------- X include 'PARAM.h' X include 'ALCAZA.h' X include 'CLASS.h' X include 'FLWORK.h' X include 'CONDEC.h' X LOGICAL DOITFL X CHARACTER SDESCR(MXSTAT)*86,STEMP*1,SLAST*1,STR1*24,STR2*20 X*--- SDESCR contains the FORTRAN statement description X*--- important for new entries: X* - scan order is top - down (see e.g. INTEGER - INTEGERFUNCTION etc.) X* - order is alphabetic X* - special characters at the end X* X* The numbers correspond to ISTMDS(6)...ISTMDS(22) X* X* no.+prty+name descrpt. X* l u s x n k h type information X DATA SDESCR( 1)/' 1 0 ASSIGN ASSIGN@TO DEF X +99 0 1 1 2 0 0 0 1 0 0 0 0 0 0'/ DEF X DATA SDESCR( 2)/' 3 0 BACKSPACE DITO DEF X +99 0 0 1 2 2 0 0 2 0 17 0 0 0 0'/ DEF X DATA SDESCR( 3)/' 4 0 BLOCKDATA DITO DEF X +99 0 0 0 1 2 1 0 1 14 0 0 0 0 0'/ DEF X DATA SDESCR( 4)/' 5 0 BUFFERIN DITO DEF X +99 0 0 1 2 2 0 0 2 0 17 0 0 0 0'/ DEF X DATA SDESCR( 5)/' 6 0 BUFFEROUT DITO DEF X +99 0 0 1 2 2 0 0 2 0 17 0 0 0 0'/ DEF X DATA SDESCR( 6)/'15 0 CONTINUE DITO DEF X +99 0 0 1 0 2 0 0 0 0 0 0 0 0 0'/ DEF X DATA SDESCR( 7)/' 7 0 CALL DITO DEF X +99 0 5 1 2 2 0 1 1 15 2 0 17 0 0'/ DEF X DATA SDESCR( 8)/'12 0 COMMON DITO DEF X +99 0 0 0 2 2 0 21 1 8 3 0 18 20 0'/ DEF X DATA SDESCR( 9)/'14 0 COMPLEXFUNCTION COMPLEX#FUNCTION DEF X +99 0 0 0 2 0 1 1 3 4 17 21 2 0 19'/ DEF X DATA SDESCR( 10)/'13 0 COMPLEX COMPLEX*@ DEF X +99 0 0 0 2 0 0 10 2 4 18 0 0 0 0'/ DEF X DATA SDESCR( 11)/'13 0 COMPLEX DITO DEF X +99 0 0 0 2 2 0 10 2 4 18 0 0 0 0'/ DEF X DATA SDESCR( 12)/' 9 0 CHARACTERFUNCTION CHARACTER#FUNCTION DEF X +99 0 0 0 2 0 1 1 3 6 17 21 2 0 19'/ DEF X DATA SDESCR( 13)/' 8 0 CHARACTER CHARACTER*@ DEF X +99 0 0 0 2 0 0 10 2 6 18 0 0 0 0'/ DEF X DATA SDESCR( 14)/' 8 0 CHARACTER DITO DEF X +99 0 0 0 2 2 0 10 2 6 18 0 0 0 0'/ DEF X DATA SDESCR( 15)/'10 0 CLOSE DITO DEF X +99 0 4 1 2 3 0 0 2 0 17 0 0 0 0'/ DEF X DATA SDESCR( 16)/'16 0 DATA DITO DEF X +99 0 0 0 2 2 0 0 1 0 0 0 0 0 0'/ DEF X DATA SDESCR( 17)/'19 0 DIMENSION DITO DEF X +99 0 0 0 2 2 0 10 2 0 18 0 0 0 0'/ DEF X DATA SDESCR( 18)/'20 1 DO DO@, DEF X + 3 0 1 1 2 0 0 0 2 0 17 0 0 0 0'/ DEF X DATA SDESCR( 19)/'20 2 DO DO@?=!, DEF X + 3 0 1 1 2 0 0 0 2 0 17 0 0 0 0'/ DEF X DATA SDESCR( 20)/'17 0 DECODE DITO DEF X +99 0 4 1 2 2 0 0 2 0 17 0 0 0 0'/ DEF X DATA SDESCR( 21)/'22 0 DOUBLEPRECISIONFUNCTION DITO DEF X +99 0 0 0 2 2 1 1 3 5 17 21 2 0 19'/ DEF X DATA SDESCR( 22)/'21 0 DOUBLEPRECISION DITO DEF X +99 0 0 0 2 2 0 10 2 5 18 0 0 0 0'/ DEF X DATA SDESCR( 23)/'26 0 END END; DEF X +99 0 0 1 0 0 0 0 0 0 0 0 0 0 0'/ DEF X DATA SDESCR( 24)/'27 0 ENDIF DITO DEF X +99 0 0 1 0 2 0 0 0 0 0 0 0 0 0'/ DEF X DATA SDESCR( 25)/'28 0 ENDFILE DITO DEF X +99 0 0 1 2 2 0 0 2 0 17 0 0 0 0'/ DEF X DATA SDESCR( 26)/'29 0 ENTRY DITO DEF X +99 0 0 0 2 2 0 1 2 0 16 1 0 0 0'/ DEF X DATA SDESCR( 27)/'30 0 EQUIVALENCE DITO DEF X +99 0 0 0 2 2 0 0 1 0 0 0 0 0 0'/ DEF X DATA SDESCR( 28)/'31 0 EXTERNAL DITO DEF X +99 0 0 0 2 2 0 0 1 12 0 0 0 0 0'/ DEF X DATA SDESCR( 29)/'23 0 ELSE ELSE; DEF X +99 0 0 1 0 0 0 0 0 0 0 0 0 0 0'/ DEF X DATA SDESCR( 30)/'24 0 ELSEIF ELSEIF(>)THEN; DEF X + 6 4 0 1 2 0 0 0 2 0 17 0 0 0 0'/ DEF X DATA SDESCR( 31)/'25 0 ENCODE DITO DEF X +99 0 4 1 2 2 0 0 2 0 17 0 0 0 0'/ DEF X DATA SDESCR( 32)/'33 0 FORMAT DITO DEF X +99 0 0 0 0 2 0 0 0 0 0 0 0 0 0'/ DEF X DATA SDESCR( 33)/'34 0 FUNCTION DITO DEF X +99 0 0 0 2 2 1 1 2 0 17 2 0 19 0'/ DEF X DATA SDESCR( 34)/'37 0 GOTO-(UNCOND.) GOTO@ DEF X +99 0 1 1 0 0 0 0 0 0 0 0 0 0 0'/ DEF X DATA SDESCR( 35)/'36 0 GOTO-(COMP.) GOTO( DEF X +99 0 2 1 2 2 0 0 2 0 17 0 0 0 0'/ DEF X DATA SDESCR( 36)/'35 0 GOTO-(ASS.) GOTO& DEF X + 4 0 2 1 2 0 0 0 1 0 0 0 0 0 0'/ DEF X DATA SDESCR( 37)/'39 0 IF-(BLOCK) IF(>)THEN; DEF X + 3 4 0 1 2 0 0 0 2 0 17 0 0 0 0'/ DEF X DATA SDESCR( 38)/'40 0 IF-(LOGICAL) IF(>)& DEF X + 3 0 0 1 2 0 0 0 2 0 17 0 0 0 0'/ DEF X DATA SDESCR( 39)/'38 0 IF-(ARITM.) IF(>)@ DEF X + 3 0 3 1 2 0 0 0 2 0 17 0 0 0 0'/ DEF X DATA SDESCR( 40)/'69 0 ILLEGAL DEF X + 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0'/ DEF X DATA SDESCR( 41)/'44 0 INTEGERFUNCTION DITO DEF X +99 0 0 0 2 2 1 1 3 1 17 21 2 0 19'/ DEF X DATA SDESCR( 42)/'43 0 INTEGER INTEGER*@ DEF X +99 0 0 0 2 0 0 10 2 1 18 0 0 0 0'/ DEF X DATA SDESCR( 43)/'43 0 INTEGER DITO DEF X +99 0 0 0 2 2 0 10 2 1 18 0 0 0 0'/ DEF X DATA SDESCR( 44)/'41 0 IMPLICIT DITO DEF X +99 0 0 0 0 2 0 2 0 0 0 0 0 0 0'/ DEF X DATA SDESCR( 45)/'42 0 INQUIRE DITO DEF X +99 0 4 1 2 3 0 0 1 0 0 0 0 0 0'/ DEF X DATA SDESCR( 46)/'45 0 INTRINSIC DITO DEF X +99 0 0 0 2 2 0 0 1 11 0 0 0 0 0'/ DEF X DATA SDESCR( 47)/'48 0 LOGICALFUNCTION DITO DEF X +99 0 0 0 2 2 1 1 3 3 17 21 2 0 19'/ DEF X DATA SDESCR( 48)/'47 0 LOGICAL LOGICAL*@ DEF X +99 0 0 0 2 0 0 10 2 3 18 0 0 0 0'/ DEF X DATA SDESCR( 49)/'47 0 LOGICAL DITO DEF X +99 0 0 0 2 2 0 10 2 3 18 0 0 0 0'/ DEF X DATA SDESCR( 50)/'46 0 LEVEL DITO DEF X +99 0 0 0 2 2 0 0 1 0 0 0 0 0 0'/ DEF X DATA SDESCR( 51)/'49 0 NAMELIST DITO DEF X +99 0 0 0 2 2 0 1 1 9 1 0 0 0 0'/ DEF X DATA SDESCR( 52)/'50 0 OPEN DITO DEF X +99 0 4 1 2 3 0 0 1 0 0 0 0 0 0'/ DEF X DATA SDESCR( 53)/'54 0 PRINT DITO DEF X +99 0 1 1 2 2 0 0 2 0 17 0 0 0 0'/ DEF X DATA SDESCR( 54)/'52 0 PARAMETER DITO DEF X +99 0 0 0 2 2 0 0 2 0 7 0 0 0 0'/ DEF X DATA SDESCR( 55)/'53 0 PAUSE DITO DEF X +99 0 0 1 0 2 0 0 0 0 0 0 0 0 0'/ DEF X DATA SDESCR( 56)/'55 0 PROGRAM DITO DEF X +99 0 0 0 1 2 1 0 1 13 0 0 0 0 0'/ DEF X DATA SDESCR( 57)/'56 0 PUNCH DITO DEF X +99 0 1 1 2 2 0 0 2 0 17 0 0 0 0'/ DEF X DATA SDESCR( 58)/'58 0 READ( DITO DEF X +99 0 4 1 2 3 0 0 2 0 17 0 0 0 0'/ DEF X DATA SDESCR( 59)/'57 0 READ DITO DEF X +99 0 1 1 2 2 0 0 2 0 17 0 0 0 0'/ DEF X DATA SDESCR( 60)/'60 0 REALFUNCTION DITO DEF X +99 0 0 0 2 2 1 1 3 2 17 21 2 0 19'/ DEF X DATA SDESCR( 61)/'59 0 REAL REAL*@ DEF X +99 0 0 0 2 0 0 10 2 2 18 0 0 0 0'/ DEF X DATA SDESCR( 62)/'59 0 REAL DITO DEF X +99 0 0 0 2 2 0 10 2 2 18 0 0 0 0'/ DEF X DATA SDESCR( 63)/'61 0 RETURN DITO DEF X +99 0 0 1 0 2 0 0 0 0 0 0 0 0 0'/ DEF X DATA SDESCR( 64)/'62 0 REWIND DITO DEF X +99 0 0 1 2 2 0 0 2 0 17 0 0 0 0'/ DEF X DATA SDESCR( 65)/'63 0 SAVE DITO DEF X +99 0 0 0 2 2 0 0 1 0 0 0 0 0 0'/ DEF X DATA SDESCR( 66)/'65 0 STOP DITO DEF X +99 0 0 1 0 2 0 0 0 0 0 0 0 0 0'/ DEF X DATA SDESCR( 67)/'66 0 SUBROUTINE DITO DEF X +99 0 0 0 2 2 1 1 1 15 2 0 19 0 0'/ DEF X DATA SDESCR( 68)/'68 0 WRITE DITO DEF X +99 0 4 1 2 3 0 0 2 0 17 0 0 0 0'/ DEF X DATA SDESCR( 69)/' 2 3 ASSIGNMENT ?= DEF X + 0 0 0 1 2 0 0 1 1 0 2 0 17 0 0'/ DEF X DATA SDESCR( 70)/' 2 4 ASSIGNMENT ?(>)= DEF X + 0 0 0 1 2 0 0 1 2 0 10 2 0 17 0'/ DEF X DATA SDESCR( 71)/' 2 5 ASSIGNMENT ?(>)(>)= DEF X + 0 0 0 1 2 0 0 1 1 0 2 0 17 0 0'/ DEF X DATA SLAST/' '/ X DATA DOITFL/.TRUE./ X include 'CONDAT.h' X* X*--- do it only once X* X IF(DOITFL) THEN X DOITFL=.FALSE. X NHEADR=0 X NPRIOR=0 X NPNAM=0 X NPSTM=0 X NCLASS=MXSTAT X DO 10 I=1,27 X IALPHA(1,I)=0 X IALPHA(2,I)=-1 X 10 CONTINUE X DO 30 I=1,MXSTAT X READ (SDESCR(I),'(2I2,44X,7I2,10I3)') (ISTMDS(J,I),J=6, X + MCLASS) X NP=ISTMDS(7,I) X IF (NP.GT.0.AND.NP.LE.NCLASS) THEN X NPRIOR=NPRIOR+1 X IPRIOR(NP)=I X ENDIF X READ (SDESCR(I),'(5X,A24,A20)') STR1,STR2 X NST1=INDEX(STR1,' ')-1 X NST2=INDEX(STR2,' ')-1 X SNAM(NPNAM+1:NPNAM+NST1)=STR1 X ISTMDS(1,I)=NPNAM+1 X NPNAM=NPNAM+NST1 X ISTMDS(2,I)=NPNAM X IF (NST2.EQ.0) THEN X*--- statement descriptor blank - indicate X ISTMDS(3,I)=0 X IF (ISTMDS(6,I).EQ.69) ILL=I X ELSEIF (STR2(1:4).EQ.'DITO') THEN X*--- use name as descriptor X SSTM(NPSTM+1:NPSTM+NST1)=STR1 X ISTMDS(3,I)=NPSTM+1 X NPSTM=NPSTM+NST1 X ISTMDS(4,I)=NPSTM X ELSE X SSTM(NPSTM+1:NPSTM+NST2)=STR2 X ISTMDS(3,I)=NPSTM+1 X NPSTM=NPSTM+NST2 X ISTMDS(4,I)=NPSTM X ENDIF X*--- set some class references X IF (ISTMDS(6,I).EQ.40) THEN X*--- logical IF X IIF=I X ELSEIF (ISTMDS(6,I).EQ.26) THEN X*--- END statement X IEND=I X ELSEIF (ISTMDS(6,I).EQ.33) THEN X*--- FORMAT X IFORMT=I X ELSEIF (ISTMDS(6,I).EQ.61) THEN X*--- RETURN X IRETUR=I X ENDIF X*--- get start of alphabetic group X STEMP=SSTM(ISTMDS(3,I):) X IF (ISTMDS(3,I).NE.0) THEN X IF (STEMP.NE.SLAST) THEN X IF (SPECCH(STEMP)) THEN X K=27 X ELSE X K=ICVAL(STEMP) X ENDIF X IALPHA(1,K)=I X IF (SLAST.NE.' ') THEN X K=ICVAL(SLAST) X IALPHA(2,K)=I-1 X ENDIF X SLAST=STEMP X ENDIF X ENDIF X K=ISTMDS(3,I)-1 X*--- find and store last alphabetic ch. in descr. X DO 20 J=ISTMDS(3,I),ISTMDS(4,I) X IF (ALPHCH(SSTM(J:J))) K=J X 20 CONTINUE X ISTMDS(5,I)=K X*--- routine headers X IF (ISTMDS(14,I).NE.0) THEN X NHEADR=NHEADR+1 X IHEADR(NHEADR)=I X ENDIF X 30 CONTINUE X IALPHA(2,27)=NCLASS X*--- end of IF(DOITFL) following X ENDIF X END / echo 'x - floppy.vmsfor' sed 's/^X//' > floppy.vmsfor << '/' X PROGRAM FLOPPY XC------------------------------------------------------------------------- XC Floppy VAX VMS interface routine. XC Sets up various required input files for Floppy. XC XC Julian Bunn 1987 XC------------------------------------------------------------------------- X PARAMETER (MLEN=256,MXLIN=80) X INTEGER*4 STATUS,CLI$GET_VALUE,CLI$PRESENT X INTEGER*4 LIB$FIND_FILE,LIB$FIND_FILE_END X INCLUDE '($SSDEF)' X INCLUDE '($RMSDEF)' X INCLUDE '($LBRDEF)' X EXTERNAL CLI$_PRESENT,CLI$_DEFAULTED,CLI$_ABSENT,CLI$_NEGATED X CHARACTER*(MXLIN) CIN,CINS,CIN2,CARD X CHARACTER*(MLEN) CFILE,CIFOR,CSCRT,CIGNO,CFORT,CFLOP,CTREE,CTEMP X CHARACTER*(MXLIN) CTEMPL X CHARACTER*(MLEN) CFORAN X LOGICAL LOG X CHARACTER*(MLEN) CMMND XC XC Log this use of FLOPPY using UMON XC X STATUS = LIB$GET_FOREIGN(CFORAN,,,) X LFORAN = MIN(MXLIN,LENOCC(CFORAN)) X CALL UMLOG('FLOPPY',CFORAN(:LFORAN)) XC X LOG = .FALSE. XC XC LOG XC X STATUS = CLI$PRESENT('LOG') X IF(STATUS.EQ.%LOC(CLI$_PRESENT).OR. X & STATUS.EQ.%LOC(CLI$_DEFAULTED)) THEN X LOG = .TRUE. X ENDIF XC XC INPUT FORTRAN XC X STATUS = CLI$GET_VALUE('P1',CIN) X IF(.NOT.STATUS) CALL LIB$SIGNAL(%VAL(STATUS)) X IB = INDEX(CIN,']') X IF(IB.EQ.0) THEN X IP = INDEX(CIN,'.') X ELSE X IP = INDEX(CIN(IB:),'.') X ENDIF X IF(IP.EQ.0) CIN = CIN(:LENOCC(CIN))//'.FOR' X IF(LOG) WRITE(6,'(2A)') ' Floppy --> Input Fortran :', X & CIN(:LENOCC(CIN)) XC XC EXTRACT STEM NAME XC X NFILE = 0 X 88 CONTINUE X STATUS = LIB$FIND_FILE(CIN,CTEMP,I) X IF(.NOT.STATUS.AND.NFILE.EQ.0) THEN X IF(LOG)WRITE(6,'(3A)') ' File ',CIN(:LENOCC(CIN)),' absent !' X CALL LIB$SIGNAL(%VAL(STATUS)) X GOTO 1000 X ENDIF X IF(.NOT.STATUS) GOTO 99 X NFILE = NFILE + 1 X IF(NFILE.EQ.1) THEN X CIFOR = CTEMP X IPOSE = INDEX(CTEMP,']') X IPOSD = INDEX(CTEMP(IPOSE:MLEN),'.') X IF(IPOSE.EQ.0.OR.IPOSD.EQ.0) GOTO 998 X CFILE = CTEMP(IPOSE+1:IPOSE+IPOSD-2) X LEN = IPOSD-2 X ELSE IF(NFILE.EQ.2) THEN X OPEN(11,FILE='FLOPTEMP.FOR',STATUS='SCRATCH',ERR=999) X OPEN(66,FILE=CIFOR(:LENOCC(CIFOR)),STATUS='OLD',READONLY) X 77 READ(66,'(A)',END=76,ERR=76) CARD X WRITE(11,'(A)') CARD X GOTO 77 X 76 CLOSE(66) X ELSE X OPEN(66,FILE=CTEMP(:LENOCC(CTEMP)),STATUS='OLD',READONLY) X 75 READ(66,'(A)',END=74,ERR=74) CARD X WRITE(11,'(A)') CARD X GOTO 75 X 74 CLOSE(66) X ENDIF X GOTO 88 X 99 STATUS = LIB$FIND_FILE_END(I) X IF(NFILE.GT.1) REWIND(11) X IF(LOG)WRITE(6,'(A,I2,A)') ' Floppy --> ',NFILE, X & ' file(s) of input FORTRAN' XC XC OPEN FLOP INPUT FILE XC X CSCRT = CFILE(:LEN)//'.FLOPINP' X OPEN(5,FILE=CSCRT(:LEN+8),ACCESS='SEQUENTIAL', X & CARRIAGECONTROL='LIST',STATUS='SCRATCH',ERR=999) XC XC WRITE USUAL FLOP INPUT CARDS XC X WRITE(5,'(A)') 'LIST,GLOBAL,TYPE;' X WRITE(5,'(A)') 'PRINT,ILLEGAL;' X WRITE(5,'(A)') 'OPTIONS,USER;' XC XC IGNORE FILE XC X IOLD = 0 X CIGNO = CFILE(:LEN)//'.FLOPIGN' X STATUS = CLI$PRESENT('OLD') X IF(STATUS.EQ.%LOC(CLI$_PRESENT)) THEN X STATUS = CLI$GET_VALUE('OLD',CIN) X IF(.NOT.STATUS) THEN X CIN = CIGNO X ENDIF X IOLD = 1 X ENDIF X STATUS = LIB$FIND_FILE(CIN,CTEMP,I) X IF(.NOT.STATUS.AND.IOLD.EQ.1) THEN X IF(LOG)WRITE(6,'(3A)') ' File ',CIN(:LENOCC(CIN)),' absent !' X CALL LIB$SIGNAL(%VAL(STATUS)) X GOTO 999 X ENDIF X STATUS = LIB$FIND_FILE_END(I) X IOPIG = 0 X IF(IOLD.EQ.1) THEN XC XC COPY OLD IGNORE FILE INTO BUFFER XC X ICHK = 0 X OPEN(94,FILE=CIN,READONLY,STATUS='OLD') X REWIND(94) X OPEN(15,FILE=CIGNO(:LIGNO),ACCESS='SEQUENTIAL', X & STATUS='SCRATCH',ERR=999) X IOPIG = 1 X 10 READ(94,'(A)',ERR=20,END=20) CARD X WRITE(15,'(A)') CARD X IF(INDEX(CARD,'CHECK RULE').NE.0) ICHK = 1 X GOTO 10 X 20 CONTINUE X CLOSE(94) X CIGNO = CIN X ENDIF X LIGNO = LENOCC(CIGNO) X IF(LOG)WRITE(6,'(A,A)') X &' Floppy --> Ignore File :',CIGNO(:LIGNO) XC XC FLOPPY OUTPUT XC X CFLOP = ' ' X STATUS = CLI$PRESENT('OUTPUT') X IF(STATUS.EQ.%LOC(CLI$_PRESENT)) THEN X CFLOP = CFILE(:LEN)//'.FLOPOUT' X STATUS = CLI$GET_VALUE('OUTPUT',CIN) X IF(STATUS) CFLOP = CIN X IF(LOG)WRITE(6,'(A,A)') ' Floppy --> Output Listing :', X & CFLOP(:LENOCC(CFLOP)) X ENDIF XC XC SOURCE FILE NUMBERS XC X STATUS = CLI$PRESENT('FULL') X IF(STATUS.EQ.%LOC(CLI$_PRESENT)) THEN X IF(LOG)WRITE(6,'(A,A)') X & ' Floppy --> List source code line numbers' X IF(IOPIG.EQ.0) OPEN(15,FILE=CIGNO(:LIGNO),ACCESS='SEQUENTIAL', X & STATUS='NEW',ERR=999) X IOPIG = 1 X WRITE(15,'(A)') '*FULL' X ENDIF XC XC IGNORABLE NAMES XC X STATUS = CLI$PRESENT('IGNORE') X IF(STATUS.EQ.%LOC(CLI$_PRESENT)) THEN X IF(LOG)WRITE(6,'(A,A)') ' Floppy --> Ignore following names' X IF(IOPIG.EQ.0) OPEN(15,FILE=CIGNO(:LIGNO),ACCESS='SEQUENTIAL', X & STATUS='NEW',ERR=999) X IOPIG = 1 X NVALU = 0 X 50 STATUS = CLI$GET_VALUE('IGNORE',CIN) X IF(STATUS.NE.%LOC(CLI$_ABSENT)) THEN X WRITE(15,'(A)') CIN(:LENOCC(CIN)) X NVALU = NVALU+1 X IF(LOG)WRITE(6,'(A,I3,A,A)') X & ' Floppy --> Ignore name',NVALU,' = ',CIN(:LENOCC(CIN)) X GOTO 50 X ENDIF X ENDIF XC XC RULE CHECKING XC X STATUS = CLI$PRESENT('CHECKS') X IF(STATUS.EQ.%LOC(CLI$_DEFAULTED)) THEN X IF(IOPIG.EQ.0) OPEN(15,FILE=CIGNO(:LIGNO),ACCESS='SEQUENTIAL', X & STATUS='NEW',ERR=999) X IOPIG = 1 X IF(ICHK.EQ.0) THEN X WRITE(15,'(A)') '*CHECK RULE *' X IF(LOG) WRITE(6,'(A)') X & ' Floppy --> Check standard set of rules' X ELSE X IF(LOG) WRITE(6,'(A,A)') ' Floppy --> Check rules ', X & 'specified in OLD file' X ENDIF X ELSE IF(STATUS.EQ.%LOC(CLI$_NEGATED)) THEN X IF(IOPIG.EQ.0) OPEN(15,FILE=CIGNO(:LIGNO),ACCESS='SEQUENTIAL', X & STATUS='NEW',ERR=999) X IOPIG = 1 X WRITE(15,'(A)') '*CHECK RULE -99' X IF(LOG) WRITE(6,'(A)') ' Floppy --> No rule checking' X ELSE IF(STATUS.EQ.%LOC(CLI$_PRESENT)) THEN X IF(IOPIG.EQ.0) OPEN(15,FILE=CIGNO(:LIGNO),ACCESS='SEQUENTIAL', X & STATUS='NEW',ERR=999) X IOPIG = 1 X CTEMPL(:MXLIN) = ' ' X NRULE = 0 X 30 STATUS = CLI$GET_VALUE('CHECKS',CIN) X IF(STATUS.NE.%LOC(CLI$_ABSENT)) THEN X IF(LENOCC(CIN).EQ.1) CIN(:2) = ' '//CIN(:1) X IF(INDEX(CIN,'-').EQ.0.OR.LENOCC(CIN).EQ.2) THEN X WRITE(15,'(A,A)') '*CHECK RULE ',CIN X ELSE X WRITE(15,'(A,A)') '*CHECK RULE ',CIN X ENDIF X IF(CTEMPL.NE.' ') THEN X CTEMPL = CTEMPL(:LENOCC(CTEMPL))//','//CIN(:LENOCC(CIN)) X ELSE X CTEMPL = CIN(:LENOCC(CIN)) X ENDIF X NRULE = NRULE + 1 X IF(LENOCC(CTEMPL).GT.MXLIN-20) THEN X IF(LOG) WRITE(6,'(A,I2,A)') ' Floppy --> Check ',NRULE, X & ' rules :'//CTEMPL(:LENOCC(CTEMPL)) X CTEMPL(:MXLIN) = ' ' X ENDIF X GOTO 30 X ENDIF X IF(LOG.AND.LENOCC(CTEMPL).GT.0) X & WRITE(6,'(A,I2,A)')' Floppy --> Check ',NRULE, X & ' rules :'//CTEMPL(:LENOCC(CTEMPL)) X ENDIF XC XC TREE PROGRAM XC X STATUS = CLI$PRESENT('TREE') X CTREE = ' ' X IF(STATUS.EQ.%LOC(CLI$_PRESENT)) THEN X WRITE(5,'(A)') 'OPTIONS,TREE;' X CTREE = CFILE(:LEN)//'.FLOPTRE' X IF(LOG)WRITE(6,'(A,A)') X & ' Floppy --> Tree output : ',CTREE(:LENOCC(CTREE)) X ENDIF XC XC SPECIAL PROCESSING XC X STATUS = CLI$PRESENT('SPECIAL') X IF(STATUS.EQ.%LOC(CLI$_PRESENT)) THEN X STATUS= CLI$GET_VALUE('SPECIAL',CIN) X IF(IOPIG.EQ.0) OPEN(15,FILE=CIGNO(:LIGNO),ACCESS='SEQUENTIAL', X & STATUS='NEW',ERR=999) X IOPIG = 1 X WRITE(15,'(A)') '*'//CIN(:20) X IF(LOG)WRITE(6,'(A,A)') X & ' Floppy --> Invoke special process for :', X & CIN(:LENOCC(CIN)) X ELSE IF(STATUS.EQ.%LOC(CLI$_DEFAULTED)) THEN X IF(IOPIG.EQ.0) OPEN(15,FILE=CIGNO(:LIGNO),ACCESS='SEQUENTIAL', X & STATUS='NEW',ERR=999) X IOPIG = 1 X WRITE(15,'(A)') '*CHECK RULE *' X IF(LOG)WRITE(6,'(A)') X & ' Floppy --> Check standard set of rules' X ENDIF XC XC TIDY OPTION XC X ITIDY = 0 X STATUS = CLI$PRESENT('TIDY') X IF(STATUS.NE.%LOC(CLI$_PRESENT)) GOTO 100 X ITIDY = 1 X IF(LOG)WRITE(6,'(A,A)') ' Floppy --> FLOP options to tidy code ' XC XC OUTPUT FORTRAN XC X CFORT = CFILE(:LEN)//'.FLOPFOR' X STATUS = CLI$PRESENT('FORTRAN') X IF(STATUS.EQ.%LOC(CLI$_PRESENT)) THEN X STATUS = CLI$GET_VALUE('FORTRAN',CIN) X IF(STATUS) CFORT = CIN X ENDIF X WRITE(5,'(A)') 'OUTPUT,FULL,COMPRESS;' X IF(LOG)WRITE(6,'(A,A)') ' Floppy --> Output Fortran :', X & CFORT(:LENOCC(CFORT)) XC XC INDENT OPTION XC X STATUS = CLI$PRESENT('INDENT') X IF(STATUS.EQ.%LOC(CLI$_PRESENT)) THEN X STATUS = CLI$GET_VALUE('INDENT',CIN) X IF(LOG)WRITE(6,'(A,A)') X & ' Floppy --> Indent by ',CIN(:LENOCC(CIN)) X WRITE(5,'(A)') 'OPTIONS,INDENT='//CIN(:LENOCC(CIN))//';' X ENDIF XC XC GROUPF XC X STATUS = CLI$PRESENT('GROUPF') X IF(STATUS.EQ.%LOC(CLI$_PRESENT)) THEN X IF(LOG)WRITE(6,'(A)') X & ' Floppy --> Group FORMAT at end of module' X WRITE(5,'(A)') 'STATEMENTS,SEPARATE;' X ENDIF XC XC GOTOS XC X STATUS = CLI$PRESENT('GOTOS') X IF(STATUS.EQ.%LOC(CLI$_PRESENT)) THEN X IF(LOG)WRITE(6,'(A)') ' Floppy --> Shift GOTOs to the right' X WRITE(5,'(A)') 'STATEMENTS,GOTO;' X ENDIF XC XC RENUMBER FORMATS XC X STATUS = CLI$PRESENT('FORMAT') X IF(STATUS.EQ.%LOC(CLI$_PRESENT)) THEN X STATUS = CLI$PRESENT('FORMAT.START') X CINS = '500' X IF(STATUS.EQ.%LOC(CLI$_PRESENT).OR. X & STATUS.EQ.%LOC(CLI$_DEFAULTED)) THEN X STATUS = CLI$GET_VALUE('FORMAT.START',CIN) X IF(LOG)WRITE(6,'(A,A)') X & ' Floppy --> Renumber FORMAT, start at ', X & CIN(:LENOCC(CIN)) X CINS = CIN X ENDIF X STATUS = CLI$PRESENT('FORMAT.STEP') X CIN2 = '10' X IF(STATUS.EQ.%LOC(CLI$_PRESENT).OR. X & STATUS.EQ.%LOC(CLI$_DEFAULTED)) THEN X STATUS = CLI$GET_VALUE('FORMAT.STEP',CIN) X IF(LOG)WRITE(6,'(A,A)') X & ' Floppy --> Renumber FORMAT, step by ', X & CIN(:LENOCC(CIN)) X CIN2 = CIN X ENDIF X WRITE(5,'(A,A)') 'STATEMENTS,FORMAT='//CINS(:LENOCC(CINS))//',' X & ,CIN2(:LENOCC(CIN2))//';' X ENDIF XC XC RENUMBER STATEMENTS XC X STATUS = CLI$PRESENT('STMNTS') X IF(STATUS.EQ.%LOC(CLI$_PRESENT)) THEN X STATUS = CLI$PRESENT('STMNTS.START') X CINS = '10' X IF(STATUS.EQ.%LOC(CLI$_PRESENT).OR. X & STATUS.EQ.%LOC(CLI$_DEFAULTED)) THEN X STATUS = CLI$GET_VALUE('STMNTS.START',CIN) X IF(LOG)WRITE(6,'(A,A)') X & ' Floppy --> Renumber STATEMENTS, start at', X & CIN(:LENOCC(CIN)) X CINS = CIN X ENDIF X STATUS = CLI$PRESENT('STMNTS.STEP') X CIN2 = '10' X IF(STATUS.EQ.%LOC(CLI$_PRESENT).OR. X & STATUS.EQ.%LOC(CLI$_DEFAULTED)) THEN X STATUS = CLI$GET_VALUE('STMNTS.STEP',CIN) X IF(LOG)WRITE(6,'(A,A)') X & ' Floppy --> Renumber STATEMENTS, step by ', X & CIN(:LENOCC(CIN)) X CIN2 = CIN X ENDIF X WRITE(5,'(A,A)') 'STATEMENTS,NUMBER='//CINS(:LENOCC(CINS))//',' X & ,CIN2(:LENOCC(CIN2))//';' X ENDIF XC X WRITE(5,'(A)') 'END;' XC X 100 CONTINUE XC X IF(LOG)WRITE(6,'(A)') X &' Floppy --> Finished parsing command string' XC XC XC open LUNs for FLOPPY XC X IF(NFILE.EQ.1) THEN X OPEN(11,FILE=CIFOR(:LENOCC(CIFOR)),READONLY,STATUS='OLD',ERR=999) X ENDIF X OPEN(99,FILE='FLOPTEMP.TXT',STATUS='SCRATCH',ERR=999) X IF(IOPIG.NE.0) THEN X REWIND(15) X ELSE X OPEN(15,FILE='FLOPTEMP.IGN',STATUS='SCRATCH',ERR=999) X ENDIF X IFOR = 0 X IF(ITIDY.EQ.0) THEN X OPEN(14,FILE='FLOPTEMP.FOR',STATUS='SCRATCH',ERR=999) X IFOR = 1 X ELSE X OPEN(14,FILE=CFORT(:LENOCC(CFORT)),STATUS='NEW', X & CARRIAGECONTROL='LIST',ERR=999) X IFOR = 1 X ENDIF X IOUT = 0 X IF(CFLOP.NE.' ') THEN X OPEN(6,FILE=CFLOP(:LENOCC(CFLOP)),STATUS='NEW',ERR=999) X IOUT = 1 X ENDIF X ITRE = 0 X IF(CTREE.NE.' ') THEN X OPEN(50,FILE=CTREE(:LENOCC(CTREE)),STATUS='NEW', X & FORM='UNFORMATTED',ERR=999) X ITRE = 1 X ENDIF X REWIND(5) XC XC now call floppy XC X CALL ALLPRO XC X CLOSE(15) X IF(ITRE.EQ.1) CLOSE(50) X IF(IFOR.EQ.1) CLOSE(14) X CLOSE(11) X CLOSE(99) X IF(IOUT.EQ.1) CLOSE(6) XC XC LOG SUCCESSFUL COMPLETION XC X CALL UMLOG('FLOPPY','Successful completion') XC X GOTO 2000 XC X 998 CONTINUE X WRITE(6,'(A)') ' Error parsing source Fortran name ' X GOTO 1000 X 999 CONTINUE X WRITE(6,'(A)') ' Error opening a Floppy file ' X 1000 WRITE(6,500) X 500 FORMAT( /,1X,'***********************************************', X & /,1X,'* F L O P P Y *', X & /,1X,'* ABORTED *', X & /,1X,'* in job preparation stage. *', X & /,1X,'***********************************************') X 2000 CONTINUE X CALL SYS$EXIT(%VAL(1)) X END / echo 'Part 04 of Floppy complete.' exit